The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/SYSOP2.PAS

Pascal/Delphi Source File | 1988-09-14 | 18.3 KB | 584 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  9-5-88 12:35 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit Sysop2;

Interface

Uses
  TPCrt, Dos, Globals, TAccess, Core1,
  Core2, TPDos, TPSTRING, Dirs, MsgMisc,
  Sysop1, Sort;


procedure sys_dir;

procedure purge_files;


  {==========================================================================}


Implementation


  procedure sys_dir;
    { Create system directory file }

  var
    TmpDrv, KepDrv  : Str3;
    This            : SectPtr;
    DestName        : DosFileName;
    t               : tad_array;
    KepReq          : Str10;
    Str             : StrTAD;
    TmpName,
    KepName         : StrPr;
    not_found       : Integer;

    procedure write_list;
      { write list of files in current section }

    var
      Str             : string;
      i               : LongInt;
      Dirspec         : StrPr;
      key, SearchKey  : DosFileName;
      need_sort       : Boolean;

      procedure write_rec;

      begin
        with nwin_rec do
          begin
            not_found := 0;
            Str := pad(name, 15);
            Write(sort_file, Str);
            if CreditType = Points then
              WriteLn(sort_file, '    Cost: ', PointValue, ' Points')
            else
              WriteLn(sort_file);
            WriteLn(sort_file, '    ', descr);
          end;
      end;

    begin
      abort := False;
      Dirspec := SetName;
      WriteLn(dir_file);
      WriteLn(dir_file);
      WriteLn(dir_file, 'File area: ', SectReq, '   (', This^.SectDesc, ')');
      WriteLn(dir_file);
      Assign(sort_file, 'SORT.TMP');
      Rewrite(sort_file);
      need_sort := False;
      if SectReq = 'NEWIN' then
        begin
          not_found := 0;
          i := Pred(FileSize(nwin_file));
          while (not brk) and (i >= 0) do
            begin
              Seek(nwin_file, i);
              Read(nwin_file, nwin_rec);
              with nwin_rec do
                begin
                  if (status = public) and (ExistFile(Dirspec+'\'+name)) then
                    begin
                      write_rec;
                      need_sort := True;
                    end
                  else
                    begin
                      Inc(not_found);
                      if not_found > 100 then
                        i := 0;
                    end;
                end;
              i := Pred(i);
            end;
          Close(sort_file);
          if need_sort then
            not_found := TurboSort(SizeOf(sort_rec), @put_recs, @less_rec, @get_recs)
          else
            begin
              Close(sort_file);
              Erase(sort_file);
            end;
          if FileSize(nwin_file) = 0 then
            WriteLn(Com, 'Newin List is empty.');
        end
      else
        begin
          SearchKey := SectReq;
          key := SectReq;
          FindKey(NewinArea, i, key);
          if OK then
            begin
              repeat
                Seek(nwin_file, i);
                Read(nwin_file, nwin_rec);
                if (nwin_rec.status = public) and ExistFile(dirspec+'\'+nwin_rec.name) then
                  begin
                    write_rec;
                    need_sort := True;
                  end;
                NextKey(NewinArea, i, key);
              until (not OK) or (key <> SearchKey) or brk;
              Close(sort_file);
              if need_sort then
                not_found := TurboSort(SizeOf(sort_rec), @put_recs, @less_rec, @get_recs)
              else
                begin
                  {$I-}
                  Close(sort_file) {$I+};
                  if IoResult = 0 then
                    Erase(sort_file);
                end;
            end
          else
            begin
              WriteLn(dir_file);
              WriteLn(dir_file, 'No files listed for this section.');
              WriteLn(dir_file);
            end;
        end;
    end;


    procedure Header;

    var
      This            : SysmPtr;
      rec             : Integer;

    begin
      This := SysmBase;
      while (This <> nil) and (This^.key <> 'G') do
        This := This^.next;
      if This^.key = 'G' then
        begin
          rec := Succ(This^.loc);
          repeat
            Seek(sysm_file, rec);
            Read(sysm_file, sysm_rec);
            Inc(rec);
            if sysm_rec[1] <> ':' then
              WriteLn(dir_file, sysm_rec);
          until EoF(sysm_file) or (sysm_rec[1] = ':');
          WriteLn(dir_file);
        end;
    end;


    procedure Center(Str : StrStd);
      { Center string on print line }

    begin
      WriteLn(dir_file, ' ': ((user_rec.columns-Length(Str)) div 2), Str);
    end;


  begin                           { sys_dir }
    Close(mesg_file);
    abort := False;
    SetSect(HomName);
    WriteLn(Com);
    Write(Com, 'Enter File Section name where SYSTEM.DIR will be written: ');
    DestName := get_section_name(' ');
    WriteLn(Com);
    if ch <> ETX then
      begin
        WriteLn(Com);
        WriteLn(Com, 'Building system directory...Please wait...');
        KepDrv := SetDrv;
        KepReq := SectReq;
        KepName := SetName;
        FindSect(DestName, TmpDrv, OK);
        if not OK then
          begin
            TmpDrv := HomDrv;
            TmpName := HomName;
          end
        else
          begin
            if DestName = 'SYSTEM' then
              TmpName := HomName
            else
              begin
                TmpName := TmpDrv;
                if (Length(HomName) > 3) and (TmpDrv = HomDrv) then
                  begin
                    TmpName := TmpName+Copy(HomName, 4, Length(HomName));
                    TmpName := TmpName+'\';
                  end;
                TmpName := TmpName+DestName;
              end;
          end;
        Assign(dir_file, TmpName+'\'+'SYSTEM.DIR');
        {$I-}
        Rewrite(dir_file) {$I+} ;
        OK := (IoResult = 0);
        if OK then
          begin
            Header;
            Center('Complete System Directory Listing');
            Center('as of');
            GetTAD(t);
            Str := FormTAD(t);
            Center(Str);
            This := SectBase;
            while (This <> nil) and (not brk) and (Online) do
              begin
                if This^.SectAccs <= val_acc then
                  begin
                    SectReq := This^.SectName;
                    SetDrv := This^.SectDrive;
                    SetName := This^.SectDrive+':\';
                    if (Length(HomName) > 3) and (SetName = HomDrv) then
                      begin
                        SetName := SetName+Copy(HomName, 4, Length(HomName));
                        SetName := SetName+'\';
                      end;
                    if Pos(':', This^.SectName) = 2 then
                      SetName := SetName+Copy(This^.SectName, 3, Length(This^.SectName))
                    else
                      SetName := SetName+This^.SectName;
                    write_list;
                  end;            {section<access}
                This := This^.next
              end;                {this<>nil}
            Close(dir_file);
            SetSect(HomName);
            SectReq := KepReq;
            SetDrv := KepDrv;
            SetName := KepName;
            ReadDir(DirEntries, DirSpace, DirBase)
          end;                    {file opened ok}
        WriteLn(Com);
      end;
    if ExistFile('SORT.TMP') then
      Erase(sort_file);
    Reset(mesg_file);
  end;


  procedure purge_files;
    { Purge various system files of extraneous records }

  var
    done            : Boolean;
    ch_sel          : Char;
    age, cur_date   : Real;
    t               : tad_array;


    procedure purge_log;
      { Purge the log file of all records }

    begin
      WriteLn(Com, 'Purging the LOG file...');
      Seek(logr_file, 0);
      Read(logr_file, logr_rec);
      Close(logr_file);
      Rewrite(logr_file);
      Write(logr_file, logr_rec);
      FlushAny(logr_file);
      WriteLn(Com);
      log(11, 'Log file');
    end;


    procedure purge_message;
      { Purge deleted messages }

    const
      col_width       = 6;

    var
      i, col_count,
      col_limit,
      req_size        : Integer;
      size            : Real;
      nsum_file       : file of summ_list;
      nmsg_file       : file of mesg_list;

    begin
      size := FileSize(summ_file)*80.0;
      req_size := Trunc(size/1024.0);
      if Frac(size/1024.0) > 0 then
        req_size := req_size+2;
      size := FileSize(mesg_file)*73.0;
      req_size := req_size+Trunc(size/1024.0);
      if Frac(size/1024.0) > 0 then
        req_size := req_size+2;
      if (diskfree(Ord(Upcase(HomDrv[1]))-64) div 1024) > req_size then
        begin
          col_limit := max(1, user_rec.columns div col_width);
          WriteLn(Com, 'Purging the MESSAGE files...');
          Assign(nsum_file, summ_name+'.$$$');
          Assign(nmsg_file, mesg_name+'.$$$');
          Rewrite(nsum_file);
          Rewrite(nmsg_file);
          Seek(summ_file, 0);
          Read(summ_file, summ_rec); { Copy message counter to new file }
          Write(nsum_file, summ_rec);
          col_count := 0;
          while not EoF(summ_file) do
            with summ_rec do
              begin
                Read(summ_file, summ_rec);
                age := cur_date-greg_to_jul(date[3], date[4], date[5]);
                if ((status = deleted) or (age > unr_days) or ((status = Seen) and (age >
                  rea_days))) and
                (num_prev <> 255) then
                  begin           {delete message}
                    if (0 = col_count mod col_limit) then
                      WriteLn(Com);
                    Write(Com, num:col_width);
                    Inc(col_count)
                  end
                else
                  begin           {save message}
                    Seek(mesg_file, st_rec);
                    st_rec := FileSize(nmsg_file);
                    Write(nsum_file, summ_rec);
                    for i := 1 to size do
                      begin
                        Read(mesg_file, mesg_rec);
                        Write(nmsg_file, mesg_rec)
                      end
                  end
              end;

          Close(summ_file);
          Close(mesg_file);
          Close(nsum_file);
          Close(nmsg_file);

          Erase(summ_file);
          Erase(mesg_file);
          Rename(nsum_file, summ_name+ext);
          Rename(nmsg_file, mesg_name+ext);

          Reset(summ_file);
          Reset(mesg_file);

          mesg_build_index(AreaSet);
          WriteLn(Com);
          log(11, 'Msg file');
        end
      else
        WriteLn(Com, 'Insufficient Disk space to purge MESSAGE files.');
    end;


    procedure purge_newin;
      { Purge deleted newin records }

    var
      new_nwin_file   : file of nwin_list;
      req_size        : Integer;
      size            : Real;
      i               : LongInt;

    begin
      size := FileSize(nwin_file)*120.0;
      req_size := Trunc(size/1024.0);
      if Frac(size/1024.0) > 0 then
        req_size := req_size+2;
      if (diskfree(Ord(Upcase(HomDrv[1]))-64) div 1024) > req_size then
        begin
          WriteLn(Com, 'Purging the NEWIN file...');
          Assign(new_nwin_file, nwin_name+'.$$$');
          Rewrite(new_nwin_file);
          Seek(nwin_file, 0);
          repeat
            {$I-}
            Read(nwin_file, nwin_rec) {$I+} ;
            if IoResult = 0 then
              if nwin_rec.status <> deleted then
                Write(new_nwin_file, nwin_rec)
          until EoF(nwin_file);
          Close(nwin_file);
          Close(new_nwin_file);

          Erase(nwin_file);
          Rename(new_nwin_file, nwin_name+ext);

          Reset(nwin_file);
          Seek(nwin_file, 1);

          if ExistFile(area_indx+ext) then
            EraseIndex(NewinArea);
          if ExistFile(name_indx+ext) then
            EraseIndex(NewinName);

          MakeIndex(NewinArea, area_indx+ext, 12, Duplicates);
          MakeIndex(NewinName, name_indx+ext, 12, Duplicates);
          WriteLn(Com, 'Indexing the NEWIN file...');
          with nwin_rec do
            begin
              i := 1;
              while (not EOF(nwin_file)) do
                begin
                  Read(nwin_file, nwin_rec);
                  AddKey(NewinArea, i, sectn);
                  AddKey(NewinName, i, name);
                  Inc(i);
                end;
            end;
          WriteLn(Com);
          log(11, 'Newin');
        end
      else
        WriteLn(Com, 'Insufficient disk space to purge NEWIN file.');
    end;


    procedure purge_user;
      { Purge outdated users }

    var
      i               : Integer;
      temp_user_loc   : LongInt;
      Str             : StrTAD;
      key             : StrName;
      temp_user_rec   : user_list;

    begin
      WriteLn(Com, 'Purging the USER file...');
      temp_user_loc := 1;
      while temp_user_loc < FileLen(DatF) do
        with temp_user_rec do
          begin
            GetRec(DatF, temp_user_loc, temp_user_rec);
            age := cur_date-greg_to_jul(laston[3], laston[4], laston[5]);
            if ((used = 0) and (not test_bit(temp_user_rec.Flags, 5)) and (((age > unv_days)
              and
              (access < val_acc)) or ((age > val_days) and (access >= val_acc)))) then
              begin               {purge the guy}
                key := pad(ln, len_ln)+pad(fn, len_fn);
                DeleteKey(IdxF, temp_user_loc, key);
                if OK then
                  begin
                    DeleteRec(DatF, temp_user_loc);
                    Str := FormTAD(laston);
                    WriteLn(Com);
                    Write(Com, key, ' ', access, ' ', Str);
                    for i := 1 to Pred(FileSize(summ_file)) do
                      { Delete messages pertaining to user }
                      begin
                        Seek(summ_file, i);
                        Read(summ_file, summ_rec);
                        if ((summ_rec.user_to = temp_user_loc) or (summ_rec.user_from =
                          temp_user_loc)) then
                          begin
                            WriteLn(Com);
                            mesg_delete;
                          end;
                      end;
                    {now clear newin file references}
                    Seek(nwin_file, 1);
                    repeat
                      {$I-}
                      Read(nwin_file, nwin_rec); {$I+}
                      if IoResult = 0 then
                        begin
                          if nwin_rec.user = temp_user_loc then
                            begin
                              nwin_rec.user := 0;
                              Seek(nwin_file, Pred(FilePos(nwin_file)));
                              Write(nwin_file, nwin_rec);
                            end;
                        end;
                    until EoF(nwin_file);
                    {now finally, the log file}
                    Seek(logr_file, 1);
                    repeat
                      {$I-}
                      Read(logr_file, logr_rec); {$I+}
                      if IoResult = 0 then
                        begin
                          if logr_rec.user = temp_user_loc then
                            begin
                              logr_rec.user := 0;
                              Seek(logr_file, Pred(FilePos(logr_file)));
                              Write(logr_file, logr_rec);
                              FlushAny(logr_file);
                            end;
                        end;
                    until EoF(logr_file);
                  end;
              end;
            Inc(temp_user_loc)
          end;
      WriteLn(Com);
      log(11, 'Users');
    end;

  begin                           {PURGE FILES}
    GetTAD(t);
    SetSect(HomName);
    cur_date := greg_to_jul(t[3], t[4], t[5]);
    done := False;
    repeat
      st := prompt('File(s) to purge <A><L><M><N><U><Q><?> ', 80, 'ES?');
      if Length(st) = 1 then
        ch_sel := st[1]
      else
        ch_sel := '?';
      case ch_sel of
        'A' :
          begin
            if (not macro_in_progress) then
              OK := ask('Do you want to purge ALL files', 'Y');
            if macro_in_progress or OK then
              begin
                purge_log;
                purge_newin;
                purge_user;
                purge_message;
                done := True
              end;
          end;
        'L' :
          if macro_in_progress then
            purge_log
          else if ask('Do you want to purge the LOG file', 'Y') then
            purge_log;
        'M' :
          if macro_in_progress then
            purge_message
          else if ask('Do you want to purge the MESSAGE files', 'Y') then
            purge_message;
        'N' :
          if macro_in_progress then
            purge_newin
          else if ask('Do you want to purge the NEWIN file', 'Y') then
            purge_newin;
        'U' :
          if macro_in_progress then
            purge_user
          else if ask('Do you want to purge the USER file', 'Y') then
            purge_user;
        'Q' :
          done := True
      else
        WriteLn(Com, '<A>ll, <L>og, <M>essage, <N>ewin, <U>ser, <Q>uit');
      end;
    until (done) or (not Online);
  end;


end.                              { of SYSOP2.PAS}